#!/usr/bin/perl

# simple AIM bot that allows you to create a "virutal chat room"
# good reference for the Net::OSCAR module
# unlike aim rooms, the chatrooms created this way work with google talk (why i use it)

use strict;
use Net::OSCAR qw(:standard);
use Encode;
use IPC::Lite;
use Data::Dumper;

my %opt;

use Getopt::Long;

$opt{rooms} = 1;

my @SARGV = @ARGV;

#see sub usage() below

GetOptions(\%opt, "conn=s@", "db=s", "conf=s", "rooms=s", "lock=i") 
	|| die usage();

sub mark;

# guess paths to db and conf if not specified
if ($opt{conf}) {
	parseconf(\%opt, $opt{conf});
	$opt{db} = ffrom($opt{conf}, '.db') 
		if (!$opt{db});
} else {
	if (!$opt{db}) {
		my $b = $ENV{HOME} ? "$ENV{HOME}/vcrbot" : $0;
		$opt{db} = ffrom($b, '.db');
	} 
}

# if not interactive shell, better make a log file
$opt{log} = ffrom($opt{conf}, '.log') 
	if (!(-t STDOUT) && !$opt{log});

$opt{rooms} = 1  if $opt{rooms} =~ /^(yes|1)$/i; 
$opt{rooms} = '' if $opt{rooms} =~ /^(no|0)$/i;

die usage() unless $opt{db} && $opt{conn};
die "vcrbot error: Invalid connection string\n\n" . usage()
	unless parseconn($opt{conn}->[0]);

if ($opt{log}) {
	open STDOUT, ">>" . $opt{log};
	open STDERR, ">&STDOUT";
}

$|=1;

mark "vcrbot start " . join(' ', @SARGV);

my $pidf;
if ($opt{lock}) {
	$pidf = new IO::File;
	open $pidf, ">$opt{lock}" || die "vcrbot error: Can't open $opt{lock} pid file: $!";
	flock($pidf, 2|4) || die "vcrbot error: Can't lock pid file $opt{lock}: $!";	
}

die "vcrbot error: need db path" if !$opt{db};

if (!$opt{rooms}) {
	$opt{start} = 'default';
}

my (%in, %user, %here);

tie %in, 'IPC::Lite', Path=>$opt{db}, Table=>"room";
tie %user, 'IPC::Lite', Path=>$opt{db}, Table=>"user";
tie %here, 'IPC::Lite', Path=>$opt{db}, Table=>"here";

my @oscar;
my @xmpp;

for (@{$opt{conn}}) {
	my ($typ, $user, $pass, $host, $port) = parseconn($_);
	if ($typ eq 'oscar') {
		push @oscar, new_oscar($user, $pass, $host, $port);
	}
	if ($typ eq 'xmpp') {
		push @xmpp, new_xmpp($user, $pass, $host, $port);
	}
}

$SIG{INT} = \&sign_off;
$SIG{TERM} = \&sign_off;

my $continue = 1;
while($continue) 
{
    for my $oscar (@oscar) {
	    next unless $oscar;
	    eval {
		$oscar->do_one_loop();
	    };
	    if ($@) {
		mark("error: $@");
	    }
    }
    for my $xmpp (@xmpp) {
	    next unless $xmpp;
	    my $ret;
            eval {
                $ret = $xmpp->Process(0);
            };
            if ($@) {
                mark("error: $@");
            }
    }
}

END {
	sign_off();
}

sub new_oscar {
	my ($u, $p, $h, $r) = @_;

	my $oscar = Net::OSCAR->new(capabilities => [qw(typing_status extended_status)], 
		rate_manage => OSCAR_RATE_MANAGE_MANUAL);

	$oscar->set_callback_im_in(\&im_in);
	$oscar->set_callback_buddy_in(\&buddy_in);
	$oscar->set_callback_buddy_out(\&buddy_out);
	$oscar->set_callback_signon_done(\&signon_done);
	$oscar->set_callback_snac_unknown(\&snac_unknown);
	$oscar->set_callback_typing_status(\&typing_status);
	$oscar->signon($u, $p);

	return $oscar;
}

sub new_xmpp {
	my ($u, $p, $h, $r) = @_;
	require Net::XMPP;
	my $x = new Net::XMPP::Client();
	$x->SetCallBacks( message=>\&xmpp_msg,
                          presence=>\&xmpp_presence,
                          iq=>\&xmpp_iq);
	my $to;
	if ($u =~ m|^(.*)\@(.*?)$|) {
		$u = $1;
		$to = $2;
	}
	if (($h eq 'talk.google.com') && !$to) {
		$to = 'gmail.com';
	}

	my $ret = $x->Connect(hostname=>$h, port=>$r, timeout=>4, tls=>1, componentname=>$to);
	if (!defined($ret)) {
		mark("error: xmpp cannot connect to $h on port $r : " . xmpp_err($x));
		return undef;
	}

	my @result = $x->AuthSend(username=>$u,
                                   password=>$p,
                                   resource=>'');

	if ($result[0] ne "ok")
	{
	    print "ERROR: Authorization failed: $result[0] - $result[1]\n";
	    $x->Disconnect();
	    return undef;
	}

	return $x;
}

sub xmpp_err {
	my $x = shift;
	my $r = $x->GetErrorCode();
	my $e;
	if (ref($r) eq 'HASH') {
		if ($r->{text}) {
			$e = $r->{text};
		} elsif ($r->{node}) {
			for ($r->{node}->children()){ 
				$e .= $_->get_cdata();
			}
		} else {
			$e = Dumper($r);
		}
	}
	return $e;
}

sub xmpp_msg {
    my $sid = shift;	
    my $message = shift;	
    my $type = $message->GetType();
    my $fromJID = $message->GetFrom("jid");
    
    my $from = $fromJID->GetUserID();
    my $resource = $fromJID->GetResource();
    my $subject = $message->GetSubject();
    my $body = $message->GetBody();
    print "===\n";
    print "Message ($type)\n";
    print "  From: $from ($resource)\n";
    print "  Subject: $subject\n";
    print "  Body: $body\n";
    print "===\n";
    print $message->GetXML(),"\n";
    print "===\n";
}

sub xmpp_iq {
    my $sid = shift;
    my $iq = shift;
    
    my $from = $iq->GetFrom();
    my $type = $iq->GetType();
    my $query = $iq->GetQuery();
    my $xmlns = $query->GetXMLNS();
    print "===\n";
    print "IQ\n";
    print "  From $from\n";
    print "  Type: $type\n";
    print "  XMLNS: $xmlns";
    print "===\n";
    print $iq->GetXML(),"\n";
    print "===\n";
}

sub xmpp_presence {
    my $sid = shift;
    my $presence = shift;
    
    my $from = $presence->GetFrom();
    my $type = $presence->GetType();
    my $status = $presence->GetStatus();
    print "===\n";
    print "Presence\n";
    print "  From $from\n";
    print "  Type: $type\n";
    print "  Status: $status\n";
    print "===\n";
    print $presence->GetXML(),"\n";
    print "===\n";
}

sub sign_off {
    	for (@oscar) {
		next unless $_;
		eval {
			$_->signoff();
		};
		$_ = undef;
	}
        for (@xmpp) {
		next unless $_;
                eval {
                        $_->Disconnect();
                };
		$_ = undef;
        }
	$continue = 0;
	if ($pidf) {
		flock($pidf, 8);
	}
}

sub signon_done {
	my ($oscar, $screenname, $status) = @_;
	my $from = lc($screenname);
	$oscar->set_visibility(VISMODE_PERMITALL);
	mark "signon done\n";
}

sub snac_unknown {
	my ($oscar, $connection, $snac, $data) = @_;
        mark("unknown snac: " . $snac->{data}) unless $snac->{data} =~ /lifestream.aim.com/;
}

sub typing_status {
	my ($oscar, $screenname, $status) = @_;
	my $from = lc($screenname);
	mark "$from typing is $status\n";
}

sub buddy_in {
	my ($oscar, $screenname, $group, $data) = @_;
	my $from = lc($screenname);
	$here{$from} = 1;
	if (keys(%here) == 2) {
		$oscar->set_away('');
	}
	mark "$from buddy in\n" unless $group eq '-';
}

sub buddy_out {
	my ($oscar, $screenname, $group) = @_;
	my $from = lc($screenname);
	delete $here{$from};
	if (keys(%here) == 1) {
		$oscar->set_away('Not in');
	}
	mark "$from buddy out\n" unless $group eq '-';
}

sub join_room {
	my ($oscar, $from, $room) = @_;
	return if $user{$from} && $user{$from}->{room} eq $room;
	if ($user{$from}->{room}) {
		delete $in{$user{$from}->{room}}->{$from};
	}
	$user{$from}->{room} = $room;
	$in{$room}->{$from} = 1;
	mark "room for $from is $room\n";
	return $room;
}

sub im_in {
	my($oscar, $from, $message, $is_away) = @_;

	my $orig_from = "$from";

	$from = lc($from);

	$message = decode('ISO-8859-1', $message, Encode::FB_QUIET);
	
	$message =~ s/<[^>]+>/ /gs;
	$message =~ s/\s+$//s;
	$message =~ s/^\s+//s;

	if ($from =~ /^aol system/) {
		mark("$from: $message");
		return;
	}

	my $user = $user{$from};
	if (!$user) {
		$oscar->add_buddy('all', $from);
		$user{$from}->{name} = $orig_from;
	}

	my $room = $user->{room} ? $user->{room} : '';
	
	if ($is_away) {
		buddy_out($oscar, $from, '-');
		return; 
	} else {
		buddy_in($oscar, $from, '-');
	}

	if (!$room && $opt{start}) {
		$room = join_room($oscar,$from, $opt{start});
	}

	if ($room eq '') {
		$message = ':'.$message if ($message =~ /^(join|room|who|help)/i);
	}

	if ($message =~ m|^:([a-z]+)\b|i) {
		my ($cmd, @arg) = split(/\s+/, $message);
		$cmd =~ s/^://;  
		$cmd = lc($cmd);
		if ($cmd eq 'join' && $opt{rooms}) {
			$room = lc($arg[0]);
			join_room($oscar, $from, $room);
			$oscar->send_im($from, "[Current room is $room]");
		} elsif ($cmd eq 'who') {
			my $where = $arg[0] ? $arg[0] : $room ;
			if (!$where) {
				$oscar->send_im($from, "[Can't list people in room (none)]");
			} else {
				my $msg = '';
				for (keys(%{$in{$room}})) {
					$msg .= "$room: $_, \n";
				}
				$oscar->send_im($from, substr($msg,0,-2));
			}
		} elsif ($cmd =~ /^unign?o?r?e/) {
			delete $user->{ignore}->{lc($1)};
			delete $user{lc($arg[0])}->{ignoredby}->{$from};
		} elsif ($cmd =~ /^igno?r?e?/) {
			$user->{ignore}->{lc($arg[0])} = 1;
			$user{lc($arg[0])}->{ignoredby}->{$from} = 1;
		} elsif ($cmd eq 'room') {
			if ($room) {
				$oscar->send_im($from, "[Current room is $room]");
			} else {
				$oscar->send_im($from, "[You're not in a room]");
			}
		} else {
			$cmd = ':help';
		}

		if ($cmd eq ':help') {
			my $help = <<EOF;
[
You can use the following commands:

 :join - to join a room
 :who - to list who's in a room
 :ignore - to ignore someone, or show your ignore list
 :unignore - to unignore someone
 :help - to get help
]
EOF
			$oscar->send_im($from, $help);
		}
		return;
	}

	if (!$room) {
		$oscar->send_im($from, "[Type :join 'roomname' to join a room]");
	}

	mark "$room: $from: $message\n";

	if ($from eq 'aol system msg') {
		return;
	}

	for (keys(%{$in{$room}})) {
		next if $_ eq $from;
		$oscar->send_im($_, "$from: " . $message);
        }
}

sub parseconn {
	my $conn = shift;
	$conn =~ s/\s+$//;
	$conn =~ s/^\s+//;
	my ($typ, $u, $pw, $h, $port) = $conn =~ m|^([^:]+://?)?([^:]+)(:.*)?\@([\w.]+):?(\d+)?$|;
	$h = lc($h);
	$typ = lc($typ);
	$typ =~ s/:$//;
	$typ = 'oscar' if !$typ && $h =~ /aim|oscar/;
	$typ = 'xmpp' if !$typ;
	$h = 'talk.google.com' if $h eq 'google';
	$pw =~ s/^://;
	$pw = $opt{pass} if !defined($pw);
	$port = '5222' if !$port && $typ eq 'xmpp';
	return undef unless $u && $h;
	return undef unless $typ eq 'oscar' || $typ eq 'xmpp';
	return ($typ, $u, $pw, $h, $port);
}

sub parseconf {
	my ($opt, $file) = @_;
	open(IN, '<'.$file) || die "vcrbot error: can't open conf $file: $!";
	while (<IN>) {
		next if /^#/;
		next if /^\s+$/;
		die "vcrbot error: configuration line $. of $file: needs NAME=VALUE" 
			if !m|^([^=]+?)\s*=\s*(.*)$|;
		my ($n, $v) = (lc($1), $2);
		if ($n eq 'conf') {
			parseconf($opt, $v);
		} else {
			$opt->{$n} = $v;
		}
	}
	close IN;
}

sub usage {
return <<EOF;
USAGE: vcrbot -conn conn1 [-conn conn2...] -db db [options]
   OR: vcrbot -conf config.file [options]

Options:
	-conn	[protocol://]user[:pass]\@host[:port]
	-pass   Default connection password
	-rooms	Can be one of 'yes or 1' (the default), 'no or 0', or a comma delimited list of allowed rooms.
	-start	Naem of starting room (ignored if rooms not allowed)
	-db	Path to db file (required)
	-lock	Path to pid/lock file

Host can be just 'aim' or 'google', or a full hostname.
Protocol should be xmpp or oscar, nomally just left blank (use default based on host).
Port defaults to 5222 for xmpp. 
Config file consists of name=value pairs (use conf=x for an include file).
Config options don't start with a dash (-).
Config lines starting with # are ignored.
Connections with unspecified passwords will use the -pass default connection password. 
Command line options override config options.

Example: vcrbot -c bot1\@aim -c password.file -l /var/run/bot1.pid
EOF
}


sub ffrom {
	my $r = shift;
	$r =~ s/\.[^.]+$//;
	$r .= shift;
}

sub mark {
	my $m = shift;
	$m =~ s/\s/ /g;
	$m =~ s/\s\s/ /g;
	$m =~ s/\s+$//g;
	$m =~ s/^\s+//g;
	print scalar(localtime), "\t", $m, "\n";
}

1;

__END__

=head1 NAME

vcrbot - Virtual Chatroom Bot

=head1 SYNOPSIS

Program that uses Net::OSCAR to create a AOL and Google Talk compatible chatroom

 ./vcrbot -u biology419 -p botpass -l chatter.log &

Conf file looks like this:

 user=biology419
 pass=botpass
 log=chatter.log
 rooms=no

Conf files can include other conf files... so you can organize multiple bots.

Turning off "rooms" means there's only one room.   It's useful for a one-off bot.

=head1 SEE ALSO

L<Net::OSCAR>, L<IPC::Lite>

=head1 AUTHOR

Erik Aronesty C<earonesty@cpan.org>

=head1 LICENSE

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

See L<http://www.perl.com/perl/misc/Artistic.html> or the included LICENSE file.

=cut


